home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 2614.ZIP / TBROWS.ZIP / TTBR6.PRG < prev    next >
Text File  |  1990-10-26  |  5KB  |  201 lines
  1. /*****
  2.  *
  3.  * TTBR6.PRG
  4.  * Sixth example for TBROWSE class using a database file
  5.  *
  6.  * 20 October 90
  7.  * Luiz Quintela - Nantucket Corp
  8.  *
  9.  * Clipper ttbr6 /N/W/A/B
  10.  * RTLINK FILE ttbr6 PLL base50
  11.  *
  12.  */
  13.  
  14. // Include Header Files
  15. #include "inkey.ch"
  16. #include "setcurs.ch"
  17.  
  18. MEMVAR GetList
  19.  
  20. FUNCTION Main()
  21. LOCAL b, column, nKey, aColors, bData
  22. SET SCOREBOARD OFF
  23. SET DATE       BRITISH
  24. SET CONFIRM    ON
  25.  
  26. USE test INDEX test NEW
  27. // Turn cursor off
  28. SETCURSOR(SC_NONE)
  29. SETCOLOR( "BG/B" ); CLS
  30.  
  31. b := TBrowseDB( 2, 2, 20, 48)
  32. b:colorSpec := "BG/B,GR+/R,W/N,N,GR+/W,W+/B,R+/B,GR+/B"
  33.  
  34. b:colSep := " │ "
  35. b:headSep := "═╤═"
  36. b:footSep := "═══"
  37.  
  38. // TBColumn objects
  39. column := TBColumnNew( "Field 1", {|| test->fld1} )
  40. column:footing := "First"
  41. b:addColumn( column )
  42. column := TBColumnNew( "Field 2", {|| test->fld2} )
  43. b:addColumn( column )
  44. column := TBColumnNew( "Field 3", {|| test->fld3} )
  45. b:addColumn( column )
  46. column := TBColumnNew( "Field 4", {|| test->fld4} )
  47. b:addColumn( column )
  48. column := TBColumnNew( "Field 5", {|| test->fld5} )
  49.  
  50. // cargo
  51. // is an instance variable of ANY DATA TYPE, allowing
  52. // arbitrary information to be attached to a TBColumn object and
  53. // retrieved later
  54. column:cargo   := {|| Recolor(column) }
  55.  
  56. column:footing := "Last"
  57. bData          := column
  58. b:addColumn( column )
  59.  
  60. // Freeze one column 
  61. b:freeze := 1
  62.  
  63. WHILE .T.
  64.    // Do not allow cursor to move into frozen columns
  65.    IF  ( b:colPos <= 1 )
  66.        // As you can see b:colPos is assignable
  67.        b:colPos := b:freeze + 1
  68.  
  69.    ENDIF
  70.  
  71.    // Stabilization
  72.    WHILE ( !b:stabilize() )
  73.       nKey := InKey()
  74.       IF ( nKey != 0 )
  75.          EXIT // abort if a key is waiting
  76.  
  77.       ENDIF
  78.  
  79.    END
  80.  
  81.    IF ( b:stable )
  82.       IF ( b:hitTop .OR. b:hitBottom )
  83.           TONE(87.3,1)
  84.          TONE(40,3.5)
  85.  
  86.       ENDIF
  87.  
  88.       // everything's done; just wait for a key
  89.       nKey := INKEY(0)         
  90.  
  91.    ENDIF
  92.  
  93.    // Process key
  94.     IF ( nKey == K_DOWN )
  95.       b:down()
  96.  
  97.    ELSEIF ( nKey == K_UP )
  98.       b:up()
  99.  
  100.    ELSEIF ( nKey == K_PGDN )
  101.       b:pageDown()
  102.  
  103.    ELSEIF ( nKey == K_PGUP )
  104.       b:pageUp()
  105.  
  106.    ELSEIF ( nKey == K_CTRL_PGUP )
  107.       b:goTop()
  108.  
  109.    ELSEIF ( nKey == K_CTRL_PGDN )
  110.       b:goBottom()
  111.  
  112.    ELSEIF ( nKey == K_RIGHT )
  113.       b:right()
  114.  
  115.    ELSEIF ( nKey == K_LEFT )
  116.       b:left()
  117.  
  118.    ELSEIF ( nKey == K_HOME )
  119.       b:home()
  120.  
  121.    ELSEIF ( nKey == K_END )
  122.       b:end()
  123.  
  124.    ELSEIF ( nKey == K_CTRL_LEFT )
  125.       b:panLeft()
  126.  
  127.    ELSEIF ( nKey == K_CTRL_RIGHT )
  128.       b:panRight()
  129.  
  130.    ELSEIF ( nKey == K_CTRL_HOME )
  131.       b:panHome()
  132.  
  133.    ELSEIF ( nKey == K_CTRL_END )
  134.       b:panEnd()
  135.  
  136.    ELSEIF ( nKey == K_ESC )
  137.         CLS; SETCURSOR(SC_NORMAL); QUIT
  138.  
  139.     ELSEIF ( nKey == K_F10 )
  140.        // Check to see if you are at the right place
  141.        IF ( b:colPos == 5 )
  142.            // If so, go ahead
  143.             // First evaluate bdata:cargo
  144.             // Check this evaluation in the UDF Recolor()
  145.  
  146.             // Now, you will replace the old column object
  147.             // with the new one
  148.             // setColumn( colPos, newObjColumn ) => currentObjColumn
  149.             // setColumn replaces the TBColumn object 
  150.             // The value returned is the current column object
  151.            b:setColumn( b:colPos, EVAL( bData:cargo ) )
  152.  
  153.             b:configure()   // Causes the TBrowse object to 
  154.             // re-examine all instance variables and TBColumn 
  155.             // objects, and them reconfigure its internal settings
  156.             // as required
  157.             b:refreshAll()  // Internally marks all data rows as
  158.             // invalid, causing them to be refilled and redisplayed
  159.             // during the next stabilize loop
  160.  
  161.         ENDIF
  162.  
  163.     ENDIF
  164.  
  165. END
  166.  
  167. FUNCTION Recolor( bBlock )
  168. // You receive the column object in bBlock
  169. LOCAL cScr  := SAVESCREEN( 6, 11, 17, 30 )
  170. LOCAL cClr  := SETCOLOR( "GR+/N,N/GR+" )
  171. LOCAL nCurs := SETCURSOR(SC_NORMAL)
  172. LOCAL nMenu := 3, nNum := 0.00
  173. @  6,11 CLEAR TO 17,30
  174. @  7,13 SAY "Select:"
  175. @  9,13 PROMPT "Less Than"
  176. @ 11,13 PROMPT "Greater Than"
  177. @ 13,13 PROMPT "Equal to"
  178. MENU TO nMenu
  179. @ 16,13 SAY "Value:" GET nNum PICTURE "99999.99"
  180. READ
  181. // Here you decide what color you will use in your\
  182. // column
  183. IF nMenu == 1
  184.    bBlock:colorBlock := { |y| IF(y < nNum, { 7, 2 },;
  185.                            { 1, 2 }) }
  186. ELSEIF nMenu == 2
  187.    bBlock:colorBlock := { |y| IF(y > nNum, { 6, 2 },;
  188.                            { 1, 2 }) }
  189. ELSE
  190.    bBlock:colorBlock := { |y| IF(y == nNum, { 8, 2 },;
  191.                            { 1, 2 }) }
  192.  
  193. ENDIF
  194. SETCURSOR(nCurs)
  195. SETCOLOR(cClr)
  196. RESTSCREEN( 6, 11, 17, 30, cScr )
  197. // And return the altered column object
  198. RETURN bBlock
  199.  
  200. /* EOF - TBBR6.PRG */
  201.